home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / library / plib.f < prev    next >
Encoding:
Text File  |  1992-06-18  |  39.0 KB  |  1,247 lines
  1. C----------------------------------------------------------------------------
  2.  
  3. C  Module name: phigslib.
  4.  
  5. C  Author: Toby Howard.
  6.  
  7. C  Function: This module contains a collection of
  8. C            useful routines, built on top of KRT3.
  9. C            See document KRT3/57 for detailed specs.
  10.  
  11. C  Hashtables used: "structureid".
  12.  
  13. C  Modification history: (Version), (Date), (name), (Description).
  14.  
  15. C  1.0, ?????, T. Howard, First version.
  16.  
  17. C  1.1, 15th July 1988, S. Larkin, Modified to work with VAX PHIGS.
  18.  
  19. C  1.2, 24th August 1988, S. Larkin, Procedure ptk_drawcolourtable added.
  20.  
  21. C  2.0, 8th January 1991, G. Williams, Converted from Pascal to C. removed
  22. C  obsolete functions.
  23.  
  24. C  2.1, 15th February 1991, G. Williams, Function ptk_findelemtype added.
  25.  
  26. C  2.2, 2nd May 1991, G. Williams, Bundled attribute functions added:
  27. C  ptk_setattrasf, ptk_setallattrasf, ptk_setedgebundlerec,
  28. C  ptk_setinteriorbundlerec, ptk_setpolylinebundlerec,
  29. C  ptk_setpolymarkerbundlerec, ptk_settextbundlerec.
  30.  
  31. C----------------------------------------------------------------------------
  32.  
  33.        INTEGER FUNCTION ptkf_readint(ws, defint, prompt, echoarea)
  34. C /*
  35. C ** \parambegin
  36. C ** \param{INTEGER}{ws}{workstation identifier}{IN}
  37. C ** \param{INTEGER}{defint}{default integer}{IN}
  38. C ** \param{CHARACTER*(*)}{prompt}{prompt string}{IN}
  39. C ** \param{REAL}{echoarea(4)}{string echo area}{IN}
  40. C ** \paramend
  41. C ** \blurb{This function reads and returns  an integer from 
  42. C ** string device 1 on workstation \pardesc{ws},
  43. C ** using \pardesc{prompt} as a prompt string.
  44. C ** If the user types a carriage-return instead of supplying an
  45. C ** integer, the function returns the specified default value 
  46. C ** \pardesc{defint}.
  47. C ** \pardesc{echoarea} specifies the echo area to use for the string device.}
  48. C */
  49.        INTEGER ws, defint
  50.        CHARACTER*(*) prompt
  51.        REAL echoarea(4)
  52.        INTEGER ptk_readint
  53.        external ptk_readint !$PRAGMA C(ptk_readint)
  54.  
  55.        ptkf_readint = ptk_readint(%val(ws), %val(defint), prompt, 
  56. & echoarea)
  57.  
  58.        RETURN
  59.        END
  60.  
  61.        REAL FUNCTION ptkf_readfloat(ws, defreal, prompt, echoarea)
  62. C /*
  63. C ** \parambegin
  64. C ** \param{INTEGER}{ws}{workstation identifier}{IN}
  65. C ** \param{REAL}{defreal}{default floating point number}{IN}
  66. C ** \param{CHARACTER*(*)}{prompt}{prompt string}{IN}
  67. C ** \param{REAL}{echoarea(4)}{string echo area}{IN}
  68. C ** \paramend
  69. C ** \blurb{This function reads and returns a real number from 
  70. C ** string device 1 on workstation \pardesc{ws},
  71. C ** using \pardesc{prompt} as a prompt string.
  72. C ** If the user types a carriage-return instead of supplying an
  73. C ** real value, the function returns the specified default value 
  74. C ** \pardesc{defreal}.
  75. C ** \pardesc{echoarea} specifies the echo area to use for the string device.}
  76. C */
  77.        INTEGER ws
  78.        REAL defreal
  79.        CHARACTER*(*) prompt
  80.        REAL echoarea(4)
  81.        REAL*8 dpdefreal
  82.        REAL ptkc_readfloat
  83.        external ptkc_readfloat !$PRAGMA C(ptkc_readfloat)
  84.  
  85.        dpdefreal = defreal
  86.        ptkf_readfloat = ptkc_readfloat(%val(ws), %val(dpdefreal), 
  87. & prompt, echoarea)
  88.  
  89.        RETURN
  90.        END
  91.  
  92.        SUBROUTINE ptkf_readstring(ws, defstring, prompt, echoarea, len, 
  93. & instr, inlen)
  94. C /*
  95. C ** \parambegin
  96. C ** \param{INTEGER}{ws}{workstation identifier}{IN}
  97. C ** \param{CHARACTER*(*)}{defstring}{default string}{IN}
  98. C ** \param{CHARACTER*(*)}{prompt}{prompt string}{IN}
  99. C ** \param{REAL}{echoarea(4)}{string echo area}{IN}
  100. C ** \param{INTEGER}{len}{number of characters allocated for input string}{IN}
  101. C ** \param{CHARACTER*(*)}{instr}{input string}{OUT}
  102. C ** \param{INTEGER}{inlen}{length of input string}{OUT}
  103. C ** \paramend
  104. C ** \blurb{This function reads and returns a real number from 
  105. C ** string device 1 on workstation \pardesc{ws},
  106. C ** using \pardesc{prompt} as a prompt string.
  107. C ** If the user types a carriage-return instead of supplying a
  108. C ** string, the function returns the specified default value 
  109. C ** \pardesc{defstring}.
  110. C ** \pardesc{echoarea} specifies the echo area to use for the string device.}
  111. C */
  112.        INTEGER ws
  113.        CHARACTER*(*) defstring, prompt
  114.        REAL echoarea(4)
  115.        INTEGER len
  116.        CHARACTER*(*) instr
  117.        INTEGER inlen
  118.        external ptk_readstring !$PRAGMA C(ptk_readstring)
  119.  
  120.        call ptk_readstring(%val(ws), defstring, prompt, echoarea,
  121. & %val(len), instr, inlen)
  122.  
  123.        RETURN
  124.        END
  125.  
  126.        SUBROUTINE ptkf_stackstruct()
  127. C /*
  128. C ** \blurb{This function stores the name
  129. C **  of the currently open structure and the position of the element
  130. C **  pointer on the structure stack, and closes the structure.}
  131. C */
  132.        external ptk_stackstruct !$PRAGMA C(ptk_stackstruct)
  133.  
  134.        call ptk_stackstruct()
  135.  
  136.        RETURN
  137.        END
  138.  
  139.        SUBROUTINE ptkf_unstackstruct()
  140. C /*
  141. C ** \blurb{This function pops the structure stack,
  142. C **  opens the structure and sets the element pointer.}
  143. C */
  144.        external ptk_unstackstruct !$PRAGMA C(ptk_unstackstruct)
  145.  
  146.        call ptk_unstackstruct()
  147.  
  148.        RETURN
  149.        END
  150.  
  151.        SUBROUTINE ptkf_openstruct(structid)
  152. C /*
  153. C ** \parambegin
  154. C ** \param{INTEGER}{structid}{structure identifier}{IN}
  155. C ** \paramend
  156. C ** \blurb{This function stores the currently open structure and
  157. C **  element pointer on
  158. C ** a stack and opens the structure {\tt structid}.}
  159. C */
  160.        INTEGER structid
  161.        external ptk_openstruct !$PRAGMA C(ptk_openstruct)
  162.  
  163.        call ptk_openstruct(%val(structid))
  164.  
  165.        RETURN
  166.        END
  167.  
  168.        SUBROUTINE ptkf_closestruct()
  169. C /*
  170. C ** \blurb{This function closes the currently open structure, and 
  171. C ** restores the open
  172. C ** structure and element pointer from the structure stack.}
  173. C */
  174.        external ptk_closestruct !$PRAGMA C(ptk_closestruct)
  175.  
  176.        call ptk_closestruct()
  177.  
  178.        RETURN
  179.        END
  180.  
  181.        SUBROUTINE ptkf_seteditmode(editmode)
  182. C /*
  183. C ** \parambegin
  184. C ** \param{INTEGER}{editmode}{edit mode}{IN}
  185. C ** \paramend
  186. C ** \blurb{This function stores
  187. C **  the current edit mode on the editmode stack and then sets the edit mode
  188. C ** to given value.}
  189. C */
  190.        INTEGER editmode
  191.        external ptk_seteditmode !$PRAGMA C(ptk_seteditmode)
  192.  
  193.        call ptk_seteditmode(%val(editmode))
  194.  
  195.        RETURN
  196.        END
  197.  
  198.        SUBROUTINE ptkf_unseteditmode()
  199. C /*
  200. C ** \blurb{This function restores the current edit mode from the 
  201. C ** edit mode stack.}
  202. C */
  203.        external ptk_unseteditmode !$PRAGMA C(ptk_unseteditmode)
  204.  
  205.        call ptk_unseteditmode()
  206.  
  207.        RETURN
  208.        END
  209.  
  210.        LOGICAL FUNCTION ptkf_getpickid(stid, elptr, pickid)
  211. C /*
  212. C ** \parambegin
  213. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  214. C ** \param{INTEGER}{elptr}{element pointer value}{IN}
  215. C ** \param{INTEGER}{pickid}{pick identifier}{OUT}
  216. C ** \paramend
  217. C ** \blurb{This function inquires the pick identifier at the element position
  218. C ** specified by \pardesc{elptr} in
  219. C **  structure \pardesc{stid}.
  220. C ** The result of the function is TRUE if the element was a pick
  221. C **  identifier, otherwise FALSE.}
  222. C */
  223.        INTEGER stid, elptr, pickid
  224.        LOGICAL*1 ptk_getpickid, ans
  225.        external ptk_getpickid !$PRAGMA C(ptk_getpickid)
  226.  
  227.        ans = ptk_getpickid(%val(stid), %val(elptr), pickid)
  228.        if (ans .eq. 1) then
  229.           ptkf_getpickid = .TRUE.
  230.        else
  231.           ptkf_getpickid = .FALSE.
  232.        endif
  233.  
  234.        RETURN
  235.        END
  236.  
  237.        LOGICAL FUNCTION ptkf_getexecuteid(stid, elptr, execid)
  238. C /*
  239. C ** \parambegin
  240. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  241. C ** \param{INTEGER}{elptr}{element pointer value}{IN}
  242. C ** \param{INTEGER}{execid}{execute structure identifier}{OUT}
  243. C ** \paramend
  244. C ** \blurb{This function inquires the execute element
  245. C **  identifier at the element position
  246. C ** specified by \pardesc{elptr} in
  247. C **  structure \pardesc{stid}.
  248. C ** The result of the function is TRUE if the element was an execute
  249. C **  element, otherwise FALSE..}
  250. C */
  251.        INTEGER stid, elptr, execid
  252.        LOGICAL*1 ptk_getexecuteid, ans
  253.        external ptk_getexecuteid !$PRAGMA C(ptk_getexecuteid)
  254.  
  255.        ans = ptk_getexecuteid(%val(stid), %val(elptr), execid)
  256.        if (ans .eq. 1) then
  257.           ptkf_getexecuteid = .TRUE.
  258.        else
  259.           ptkf_getexecuteid = .FALSE.
  260.        endif
  261.  
  262.        RETURN
  263.        END
  264.  
  265.        INTEGER FUNCTION ptkf_elemcount(stid)
  266. C /*
  267. C ** \parambegin
  268. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  269. C ** \paramend
  270. C ** \blurb{This functions counts the number of elements 
  271. C ** in  structure \pardesc{stid},
  272. C ** returning  the number of elements, or -1 if the structure does
  273. C ** not exist.}
  274. C */
  275.        INTEGER stid
  276.        external ptk_elemcount !$PRAGMA C(ptk_elemcount)
  277.  
  278.        ptkf_elemcount = ptk_elemcount(%val(stid))
  279.  
  280.        RETURN
  281.        END
  282.  
  283.        LOGICAL FUNCTION ptkf_structexists(stid)
  284. C /*
  285. C ** \parambegin
  286. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  287. C ** \paramend
  288. C ** \blurb{This function checks if structure \pardesc{stid} exists 
  289. C ** in the CSS, returning TRUE if it exists, otherwise FALSE.}
  290. C */
  291.        INTEGER stid
  292.        LOGICAL*1 ptk_structexists, ans
  293.        external ptk_structexists !$PRAGMA C(ptk_structexists)
  294.  
  295.        ans = ptk_structexists(stid)
  296.        if (ans .eq. 1) then
  297.           ptkf_structexists = .TRUE.
  298.        else
  299.           ptkf_structexists = .FALSE.
  300.        endif
  301.  
  302.        RETURN
  303.        END
  304.  
  305.        SUBROUTINE ptkf_getelemtype(elemstr, eltype)
  306. C /*
  307. C ** \parambegin
  308. C ** \param{CHARACTER*(*)}{elemstr}{string giving element type}{IN}
  309. C ** \param{INTEGER}{eltype}{element type}{OUT}
  310. C ** \paramend
  311. C ** \blurb{This function converts the string \pardesc{elemstr}
  312. C ** into its corresponding element type. For example the element type for
  313. C **  "polyline3", would be PEPL3.}
  314. C */
  315.        CHARACTER*(*) elemstr
  316.        INTEGER eltype
  317.        external ptk_getelemtype !$PRAGMA C(ptk_getelemtype)
  318.  
  319.        call ptk_getelemtype(elemstr, eltype)
  320.  
  321.        RETURN
  322.        END
  323.  
  324.        SUBROUTINE ptkf_getelemtypename(eltype, size, elemstr, 
  325. & totalsize)
  326. C /*
  327. C ** \parambegin
  328. C ** \param{INTEGER}{eltype}{element type}{IN}
  329. C ** \param{INTEGER}{size}{size of buffer allocated by application}{IN}
  330. C ** \param{CHARACTER*(*)}{elemstr}{string giving element type}{OUT}
  331. C ** \param{INTEGER}{totalsize}{length of string}{OUT}
  332. C ** \paramend
  333. C ** \blurb{This function converts element type \pardesc{eltype}
  334. C **  into the corresponding character string, which is returned in
  335. C ** \pardesc{elemstr}. For example, the string corresponding to
  336. C ** PEPL3 would be "polyline3".}
  337. C */
  338.        INTEGER eltype, size
  339.        CHARACTER*(*) elemstr
  340.        INTEGER totalsize
  341.        external ptk_getelemtypename !$PRAGMA C(ptk_getelemtypename)
  342.  
  343.        call ptk_getelemtypename(%val(eltype), %val(size), elemstr, 
  344. & totalsize)
  345.  
  346.        RETURN
  347.        END
  348.  
  349.        SUBROUTINE ptkf_copyelem(structid, elemid)
  350. C /*
  351. C ** \parambegin
  352. C ** \param{INTEGER}{structid}{structure identifier}{IN}
  353. C ** \param{INTEGER}{elemid}{element number}{IN}
  354. C ** \paramend
  355. C ** \blurb{This function copies the element at position \pardesc{elemid}
  356. C ** in structure \pardesc{structid}, into the currently
  357. C ** open structure.}
  358. C */
  359.        INTEGER structid, elemid
  360.        external ptk_copyelem !$PRAGMA C(ptk_copyelem)
  361.  
  362.        call ptk_copyelem(%val(structid), %val(elemid))
  363.  
  364.        RETURN
  365.        END
  366.  
  367.        SUBROUTINE ptkf_copyelemrange(stid, elem1, elem2)
  368. C /*
  369. C ** \parambegin
  370. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  371. C ** \param{INTEGER}{elem1}{element pointer}{IN}
  372. C ** \param{INTEGER}{elem2}{element pointer}{IN}
  373. C ** \paramend
  374. C ** \blurb{This function copies the  element range \pardesc{elem1} to
  375. C ** \pardesc{elem2}
  376. C ** in structure \pardesc{stid} into the currently open structure.}
  377. C */
  378.        INTEGER stid, elem1, elem2
  379.        external ptk_copyelemrange !$PRAGMA C(ptk_copyelemrange)
  380.  
  381.        call ptk_copyelemrange(%val(stid), %val(elem1), %val(elem2))
  382.  
  383.        RETURN
  384.        END
  385.  
  386.        SUBROUTINE ptkf_getprimitivetypename(attr, size, attrstr, 
  387. & totalsize)
  388. C /*
  389. C ** \parambegin
  390. C ** \param{INTEGER}{attr}{primitive type}{IN}
  391. C ** \param{INTEGER}{size}{size of buffer allocated by application}{IN}
  392. C ** \param{CHARACTER*(*)}{attrstr}{string giving primitive type}{OUT}
  393. C ** \param{INTEGER}{totalsize}{length of string}{OUT}
  394. C ** \paramend
  395. C ** \blurb{The function converts the  primitive type \pardesc{attr}
  396. C **  to its corresponding character string, which is returned in
  397. C ** \pardesc{artrstr}. For example, PPLATT would give "polyline".}
  398. C */
  399.        INTEGER attr, size
  400.        CHARACTER*(*) attrstr
  401.        INTEGER totalsize
  402.        external ptk_getprimitivetypename 
  403. & !$PRAGMA C(ptk_getprimitivetypename)
  404.  
  405.        call ptk_getprimitivetypename(%val(attr), %val(size), 
  406. & attrstr, totalsize)
  407.  
  408.        RETURN
  409.        END
  410.  
  411.        LOGICAL FUNCTION ptkf_removestruct(stid)
  412. C /*
  413. C ** \parambegin
  414. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  415. C ** \paramend
  416. C ** \blurb{This function deletes structure \pardesc{stid}, 
  417. C ** if it already exists,
  418. C ** returning TRUE if the structure was deleted, otherwise FALSE.}
  419. C */
  420.        INTEGER stid
  421.        LOGICAL*1 ptk_removestruct, ans
  422.        external ptk_removestruct !$PRAGMA C(ptk_removestruct)
  423.  
  424.        ans = ptk_removestruct(%val(stid))
  425.        if (ans .eq. 1) then
  426.           ptkf_removestruct = .TRUE.
  427.        else
  428.           ptkf_removestruct = .FALSE.
  429.        endif
  430.  
  431.        RETURN
  432.        END
  433.  
  434.        SUBROUTINE ptkf_findelemtype(eltypelst, lenlst, srchdir, 
  435. & srchstat, elptr, lstnum)
  436. C /*
  437. C ** \parambegin
  438. C ** \param{INTEGER}{eltypelst(*)}{list of element types}{IN}
  439. C ** \param{INTEGER}{lenlst}{length of element type list}{IN}
  440. C ** \param{INTEGER}{srchdir}{search direction, forwards or backwards}{IN}
  441. C ** \param{INTEGER}{srchstat}{search success or failure}{OUT}
  442. C ** \param{INTEGER}{elptr}{found element pointer}{OUT}
  443. C ** \param{INTEGER}{lstnum}{index of found item in list}{OUT}
  444. C ** \paramend
  445. C ** \blurb{This function searches the currently open
  446. C ** structure, starting at the current element pointer and proceeding in
  447. C **  direction \pardesc{srchdir}, for the first element whose type
  448. C ** matches any of those given in \pardesc{contentlst}.}
  449. C */
  450.        INTEGER eltypelst(*), lenlst, srchdir, srchstat, elptr, lstnum
  451.        external ptk_findelemtype !$PRAGMA C(ptk_findelemtype)
  452.  
  453.        call ptk_findelemtype(eltypelst, %val(lenlst), %val(srchdir), 
  454. & %val(srchstat), elptr, lstnum)
  455.  
  456.        RETURN
  457.        END
  458.  
  459.        LOGICAL FUNCTION ptkf_findnextpickid(stid, srchdir, eltptr, 
  460. & pickid)
  461. C /*
  462. C ** \parambegin
  463. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  464. C ** \param{INTEGER}{srchdir}{search direction}{IN}
  465. C ** \param{INTEGER}{eltptr}{element pointer of pick identifier}{OUT}
  466. C ** \param{INTEGER}{pickid}{pick identifier value}{OUT}
  467. C ** \paramend
  468. C ** \blurb{This function searches structure \pardesc{stid}, starting
  469. C ** at element \pardesc{elptr} and proceeding in direction \pardesc{srchdir},
  470. C ** looking for a pick identifier structure element. The function
  471. C ** returns TRUE if a pick identifier was found, otherwise FALSE.}
  472. C */
  473.        INTEGER stid, srchdir, eltptr, pickid
  474.        LOGICAL*1 ptk_findnextpickid, ans
  475.        external ptk_findnextpickid !$PRAGMA C(ptk_findnextpickid)
  476.  
  477.        ans = ptk_findnextpickid(%val(stid), %val(srchdir), eltptr, 
  478. & pickid)
  479.        if (ans .eq. 1) then
  480.           ptkf_findnextpickid = .TRUE.
  481.        else
  482.           ptkf_findnextpickid = .FALSE.
  483.        endif
  484.  
  485.        RETURN
  486.        END
  487.  
  488.        LOGICAL FUNCTION ptkf_findlabel(label, eltptr)
  489. C /*
  490. C ** \parambegin
  491. C ** \param{INTEGER}{label}{label value}{IN}
  492. C ** \param{INTEGER}{elemptr}{element pointer of label element}{IN/OUT}
  493. C ** \paramend
  494. C ** \blurb{This function searches forwards through the currently open
  495. C ** structure from the current editing position
  496. C ** looking for a label structure element. The function
  497. C ** returns TRUE if {\tt label} was found, otherwise FALSE.}
  498. C */
  499.        INTEGER label, eltptr
  500.        LOGICAL*1 ptk_findlabel, ans
  501.        external ptk_findlabel !$PRAGMA C(ptk_findlabel)
  502.  
  503.        ans = ptk_findlabel(%val(label), eltptr)
  504.        if (ans .eq. 1) then
  505.           ptkf_findlabel = .TRUE.
  506.        else
  507.           ptkf_findlabel = .FALSE.
  508.        endif
  509.  
  510.        RETURN
  511.        END
  512.  
  513.        SUBROUTINE ptkf_delelemtype(stid, lenlst, eltypelst)
  514. C /*
  515. C ** \parambegin
  516. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  517. C ** \param{INTEGER}{lenlst}{length of element type list}{IN}
  518. C ** \param{INTEGER}{eltypelst(*)}{list of element types to delete}{IN}
  519. C ** \paramend
  520. C ** \blurb{This function deletes every element in 
  521. C ** structure \pardesc{stid}, whose
  522. C ** type matches one of the types  in \pardesc{eltypelst}}.
  523. C */
  524.        INTEGER stid, lenlst, eltypelst(*)
  525.        external ptk_delelemtype !$PRAGMA C(ptk_delelemtype)
  526.  
  527.        call ptk_delelemtype(%val(stid), %val(lenlst), eltypelst)
  528.  
  529.        RETURN
  530.        END
  531.  
  532.        SUBROUTINE ptkf_delelem(numelems)
  533. C /*
  534. C ** \parambegin
  535. C ** \param{INTEGER}{numelems}{number of elements to delete}{IN}
  536. C ** \paramend
  537. C ** \blurb{This function deletes the \pardesc{numelems} elements from the
  538. C ** open structure, starting at the element pointer. If \pardesc{numelems} is
  539. C **  0, all elements up to the end of
  540. C ** the structure are deleted.}
  541. C */
  542.        INTEGER numelems
  543.        external ptk_delelem !$PRAGMA C(ptk_delelem)
  544.  
  545.        call ptk_delelem(%val(numelems))
  546.  
  547.        RETURN
  548.        END
  549.  
  550.        INTEGER FUNCTION ptkf_countchildren(stid)
  551. C /*
  552. C ** \parambegin
  553. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  554. C ** \paramend
  555. C ** \blurb{The function returns the number of structures 
  556. C ** executed by structure \pardesc{stid}.
  557. C ** This is the number of direct execute elements in the structure.}
  558. C */
  559.        INTEGER stid
  560.        INTEGER ptk_countchildren
  561.        external ptk_countchildren !$PRAGMA C(ptk_countchildren)
  562.  
  563.        ptkf_countchildren = ptk_countchildren(%val(stid))
  564.  
  565.        RETURN
  566.        END
  567.  
  568.        INTEGER FUNCTION ptkf_countuniqchildren(stid)
  569. C /*
  570. C ** \parambegin
  571. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  572. C ** \paramend
  573. C ** \blurb{This function returns the number of unique children of  structure
  574. C ** \pardesc{stid}. Thus, if a structure executed 
  575. C ** structures A, B and C, it would
  576. C ** have 3 unique children, regardless of how many times each of
  577. C ** A, B and C were executed.}
  578. C */
  579.        INTEGER stid
  580.        INTEGER ptk_countuniqchildren
  581.        external ptk_countuniqchildren !$PRAGMA C(ptk_countuniqchildren)
  582.  
  583.        ptkf_countuniqchildren = ptk_countuniqchildren(%val(stid))
  584.  
  585.        RETURN
  586.        END
  587.  
  588.        SUBROUTINE ptkf_inqstructnetids(root, num, stids, totalnum)
  589. C /*
  590. C ** \parambegin
  591. C ** \param{INTEGER}{root}{structure network identifer}{IN}
  592. C ** \param{INTEGER}{size}{number of integers allocated in integer list}{IN}
  593. C ** \param{INTEGER}{stids(*)}{list of structure identifiers}{OUT}
  594. C ** \param{INTEGER}{totalsize}{actual number of integers in integer list}{OUT}
  595. C ** \paramend
  596. C ** \blurb{This function returns the
  597. C **  list of unique structure identifiers in the structure network whose 
  598. C ** root is \pardesc{root}.} 
  599. C */
  600.        INTEGER root, num, stids(num), totalnum
  601.        external ptkc_inqstructnetids !$PRAGMA C(ptkc_inqstructnetids)
  602.  
  603.        call ptkc_inqstructnetids(%val(root), %val(num), stids, 
  604. & totalsize)
  605.  
  606.        RETURN
  607.        END
  608.  
  609.        SUBROUTINE ptkf_structsummary(fileptr)
  610. C /*
  611. C ** \parambegin
  612. C ** \param{INTEGER}{fileptr}{file pointer}{IN}
  613. C ** \paramend
  614. C ** \blurb{This function outputs a summary of all the structures in the 
  615. C ** CSS to
  616. C ** file \pardesc{fileptr}, which should be an open writeable file.
  617. C ** The structure identifier of each structure is printed, together 
  618. C ** with its hashed string name, if it has one. The format 
  619. C ** of the list is: {\tt \\
  620. C ** \ \ \ \ \ List of structures in the CSS\\
  621. C ** \ \ \ \ \ -----------------------------\\
  622. C ** \ \\
  623. C ** \ \ \ \ \ structure 1 "helicopter"\\
  624. C ** \ \ \ \ \ structure 45 \\
  625. C ** \ \ \ \ \ structure 51 "helicopter"\\
  626. C ** \ \ \ \ \ etc. }
  627. C ** .}
  628. C */
  629.        INTEGER fileptr
  630.        external ptk_structsummary !$PRAGMA C(ptk_structsummary)
  631.  
  632.        call ptk_structsummary(getfilep(fileptr))
  633.  
  634.        RETURN
  635.        END
  636.  
  637.        SUBROUTINE ptkf_setattrasf(numattrs, attrs, asf)
  638. C /*
  639. C ** \parambegin
  640. C ** \param{INTEGER}{numattrs}{length of attribute list}{IN}
  641. C ** \param{INTEGER}{attrs(*)}{attribute list}{IN}
  642. C ** \param{INTEGER}{asf}{aspect source flag}{IN}
  643. C ** \paramend
  644. C ** \blurb{This function inserts a structure element into
  645. C ** the open structure to set the aspect source flags for each of the
  646. C ** \pardesc{numattrs} attributes in the
  647. C **  list \pardesc{attrs}, according to \pardesc{asf}.}
  648. C */
  649.        INTEGER numattrs, attrs(*), asf
  650.        external ptk_setattrasf !$PRAGMA C(ptk_setattrasf)
  651.  
  652.        call ptk_setattrasf(%val(numattrs), attrs, %val(asf))
  653.  
  654.        RETURN
  655.        END
  656.  
  657.        SUBROUTINE ptkf_setallattrasf(asf)
  658. C /*
  659. C ** \parambegin
  660. C ** \param{INTEGER}{asf}{aspect source flag}{IN}
  661. C ** \paramend
  662. C ** \blurb{This function inserts a structure element into
  663. C ** the open structure to set the aspect source flags for all primitive 
  664. C ** attribiutes, according to \pardesc{asf}.}
  665. C */
  666.        INTEGER asf
  667.        external ptk_setallattrasf !$PRAGMA C(ptk_setallattrasf)
  668.  
  669.        call ptk_setallattrasf(asf)
  670.  
  671.        RETURN
  672.        END
  673.  
  674.        SUBROUTINE ptkf_computecharsize(wsid, str, box, font, charht, 
  675. & charexp)
  676. C /*
  677. C ** \parambegin
  678. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  679. C ** \param{CHARACTER*(*)}{str}{string}{IN}
  680. C ** \param{REAL}{box(2)}{width and height of box}{IN}
  681. C ** \param{INTEGER}{font}{text font}{IN}
  682. C ** \param{REAL}{charht}{character height}{OUT}
  683. C ** \param{REAL}{charexp}{character expansion}{OUT}
  684. C ** \paramend
  685. C ** \blurb{This function computes the character height and expansion for 
  686. C **  string \pardesc{str}, using font \pardesc{font}, 
  687. C ** in order for it to fit into the rectangle specifed by \pardesc{box}.}
  688. C */
  689.        INTEGER wsid
  690.        CHARACTER*(*) str
  691.        REAL box(2)
  692.        INTEGER font
  693.        REAL charht, charexp
  694.        external ptk_computecharsize !$PRAGMA C(ptk_computecharsize)
  695.  
  696.        call ptk_computecharsize(%val(wsid), str, box, %val(font), 
  697. & charht, charexp)
  698.  
  699.        RETURN
  700.        END
  701.  
  702.        SUBROUTINE ptkf_computecharheight(wsid, str, box, font, charht)
  703. C /*
  704. C ** \parambegin
  705. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  706. C ** \param{CHARACTER*(*)}{str}{string}{IN}
  707. C ** \param{REAL}{box(2)}{width and height of box}{IN}
  708. C ** \param{INTEGER}{font}{text font}{IN}
  709. C ** \param{REAL}{charht}{character height}{OUT}
  710. C ** \paramend
  711. C ** \blurb{This function computes the character height for 
  712. C **  string \pardesc{str}, using font \pardesc{font}, 
  713. C ** in order for it to fit into the rectangle specifed by \pardesc{box}.}
  714. C */
  715.        INTEGER wsid
  716.        CHARACTER*(*) str
  717.        REAL box(2)
  718.        INTEGER font
  719.        REAL charht
  720.        external ptk_computecharheight !$PRAGMA C(ptk_computecharheight)
  721.  
  722.        call ptk_computecharheight(%val(wsid), str, box, %val(font), 
  723. & charht)
  724.  
  725.        RETURN
  726.        END
  727.  
  728.        SUBROUTINE ptkf_setstandardviewport(vlimits, vwormt, vwmpmt, 
  729. & vwcplm, xyclpi, bclipi, fclipi)
  730. C /*
  731. C ** \parambegin
  732. C ** \param{REAL}{vlimits(6)}{viewport bounding box}{IN}
  733. C ** \param{REAL}{vwormt(4, 4)}{view orientation matrix}{OUT}
  734. C ** \param{REAL}{vwmpmt(4, 4)}{view mapping matrix}{OUT}
  735. C ** \param{REAL}{vwcplm(6)}{view clipping limits}{OUT}
  736. C ** \param{INTEGER}{xyclpi}{x-y clipping indicator}{OUT}
  737. C ** \param{INTEGER}{bclipi}{back clipping indicator}{OUT}
  738. C ** \param{INTEGER}{fclipi}{front clipping indicator}{OUT}
  739. C ** \paramend
  740. C ** \blurb{For a window of [0,1], this function creates 
  741. C ** a view representation for a viewport of \pardesc{vlimits}.}
  742. C */
  743.        REAL vlimits(6)
  744.        REAL vwormt(4, 4)
  745.        REAL vwmpmt(4, 4)
  746.        REAL vwcplm(6)
  747.        INTEGER xyclpi, bclipi, fclipi
  748.        INTEGER err
  749.        REAL window(4)
  750.  
  751.        call ptkf_limit(0.0, 1.0, 0.0, 1.0, window)
  752.        call pevmm3(window, vlimits, 0, 0.5, 0.5, 2.0, 1.0, 
  753. & -1.0, 1.0, err, vwmpmt)
  754.        call ptkf_unitmatrix3(vwormt)
  755.        do 10, i=1,6
  756.  10       vwcplm(i) = vlimits(i)
  757.        xyclpi = PCLIP
  758.        bclipi = PCLIP
  759.        fclipi = PCLIP
  760.  
  761.        RETURN
  762.        END
  763.  
  764.        SUBROUTINE ptkf_poststruct(wsid, stid, priority)
  765. C /*
  766. C ** \parambegin
  767. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  768. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  769. C ** \param{REAL}{priority}{priority with which to post structure}{IN}
  770. C ** \paramend
  771. C ** \blurb{This function posts structure \pardesc{stid} to
  772. C ** workstation \pardesc{wsid}, but only if the structure exists.}
  773. C */
  774.        INTEGER wsid, stid
  775.        REAL priority
  776.        REAL*8 dppriority
  777.        external ptk_poststruct !$PRAGMA C(ptk_poststruct)
  778.  
  779.        dppriority = priority
  780.        call ptk_poststruct(%val(wsid), %val(stid), %val(dppriority))
  781.  
  782.        RETURN
  783.        END
  784.  
  785.        SUBROUTINE ptkf_postrelative(ws, structid, relpriority, 
  786. & relstruct, error)
  787. C /*
  788. C ** \parambegin
  789. C ** \param{INTEGER}{ws}{workstation identifier}{IN}
  790. C ** \param{INTEGER}{structid}{structure identifier}{IN}
  791. C ** \param{INTEGER}{relpriority}{relative priority}{IN}
  792. C ** \param{INTEGER}{relstruct}{relative structure identifier}{IN}
  793. C ** \param{INTEGER}{error}{error code}{OUT}
  794. C ** \paramend
  795. C ** \blurb{This function posts structure \pardesc{structid} at a
  796. C **  priority higher or
  797. C ** lower than that of structure \pardesc{relative structure identifier},
  798. C **  according to \pardesc{relative priority}. 
  799. C **  If \pardesc{relative structure identifier} does not exist, 
  800. C ** \pardesc{error} is set to 
  801. C ** 1. Otherwise, its value is 0.}
  802. C */
  803.        INTEGER ws, structid, relpriority, relstruct, error
  804.        external ptk_postrelative !$PRAGMA C(ptk_postrelative)
  805.  
  806.        call ptk_postrelative(%val(ws), %val(structid), 
  807. & %val(relpriority), %val(relstruct), error)
  808.  
  809.        RETURN
  810.        END
  811.  
  812.        SUBROUTINE ptkf_changepostpriority(ws, structid, relpriority, 
  813. & relstruct, error)
  814. C /*
  815. C ** \parambegin
  816. C ** \param{INTEGER}{ws}{workstation identifier}{IN}
  817. C ** \param{INTEGER}{structid}{structure identifier}{IN}
  818. C ** \param{INTEGER}{relpriority}{relative priority}{IN}
  819. C ** \param{INTEGER}{relstruct}{relative structure identifier}{IN}
  820. C ** \param{INTEGER}{error}{error code}{OUT}
  821. C ** \paramend
  822. C ** \blurb{This function changes the priority of structure \pardesc{structid}
  823. C **  to immediately higher or lower than that of \pardesc{relstruct},
  824. C ** according to \pardesc{relpriority}. 
  825. C ** If \pardesc{structid} does not exist, 
  826. C ** \pardesc{error} is set to 
  827. C ** 1. Otherwise, its value is 0.}
  828. C */
  829.        INTEGER ws, structid, relpriority, relstruct, error
  830.        external ptk_changepostpriority 
  831. & !$PRAGMA C(ptk_changepostpriority)
  832.  
  833.        call ptk_changepostpriority(%val(ws), %val(structid), 
  834. & %val(relpriority), %val(relstruct), error)
  835.  
  836.        RETURN
  837.        END
  838.  
  839.        SUBROUTINE ptkf_inqpostpriority(wsid, structid, priority,
  840. & err)
  841. C /*
  842. C ** \parambegin
  843. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  844. C ** \param{INTEGER}{structid}{structure identifier}{IN}
  845. C ** \param{REAL}{priority}{priority value}{IN}
  846. C ** \param{INTEGER}{err}{error indicator}{OUT}
  847. C ** \paramend
  848. C ** \blurb{This function returns the priority of posted structure
  849. C ** \pardesc{structid}.
  850. C ** If \pardesc{structid} does not exist, 
  851. C ** \pardesc{error} is set to 
  852. C ** 1. Otherwise, its value is 0.}
  853. C */
  854.        INTEGER wsid, structid
  855.        REAL priority
  856.        INTEGER err
  857.        external ptk_inqpostpriority !$PRAGMA C(ptk_inqpostpriority)
  858.  
  859.        call ptk_inqpostpriority(%val(wsid), %val(structid),
  860. & priority, err)
  861.  
  862.        RETURN
  863.        END
  864.  
  865.        SUBROUTINE ptkf_redrawallstructs(wsid, flag)
  866. C /*
  867. C ** \parambegin
  868. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  869. C ** \param{INTEGER}{flag}{control flag}{IN}
  870. C ** \paramend
  871. C ** \blurb{This function calls REDRAW ALL STRUCTURES only if the
  872. C ** visual state of the workstation is deferred.}
  873. C */
  874.        INTEGER wsid, flag
  875.        external ptk_redrawallstructs !$PRAGMA C(ptk_redrawallstructs)
  876.  
  877.        call ptk_redrawallstructs(%val(wsid), %val(flag))
  878.  
  879.        RETURN
  880.        END
  881.  
  882.        SUBROUTINE ptkf_drawcolourtable(stid, llim, ulim)
  883. C /*
  884. C ** \parambegin
  885. C ** \param{INTEGER}{stid}{structure identifier}{IN}
  886. C ** \param{INTEGER}{llim}{lower index value of colour table range}{IN}
  887. C ** \param{INTEGER}{ulim}{upper limit of colour table range.}{IN}
  888. C ** \paramend
  889. C ** \blurb{This function draws a rectangular array of boxes representing
  890. C ** the range \pardesc{llim} to \pardesc{ulim} of
  891. C ** the workstation colour table. The boxes are drawn into structure
  892. C ** \pardesc{stid}.}
  893. C */
  894.        INTEGER stid, llim, ulim
  895.        external ptk_drawcolourtable !$PRAGMA C(ptk_drawcolourtable)
  896.  
  897.        call ptk_drawcolourtable(%val(stid), %val(llim), %val(ulim))
  898.  
  899.        RETURN
  900.        END
  901.  
  902.        SUBROUTINE ptkf_copycolourtable(sourcewsid, destwsid)
  903. C /*
  904. C ** \parambegin
  905. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  906. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  907. C ** \paramend
  908. C ** \blurb{This function copies the colour
  909. C **  table from workstation \pardesc{sourcewsid} to
  910. C **  workstation \pardesc{destwsid}.}
  911. C */
  912.        INTEGER sourcewsid, destwsid
  913.        external ptk_copycolourtable !$PRAGMA C(ptk_copycolourtable)
  914.  
  915.        call ptk_copycolourtable(%val(sourcewsid), %val(destwsid))
  916.  
  917.        RETURN
  918.        END
  919.  
  920.        SUBROUTINE ptkf_copylinetable(sourcewsid, destwsid)
  921. C /*
  922. C ** \parambegin
  923. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  924. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  925. C ** \paramend
  926. C ** \blurb{This function copies the polyline bundle
  927. C **  table from workstation \pardesc{sourcewsid} to
  928. C **  workstation \pardesc{destwsid}.}
  929. C */
  930.        INTEGER sourcewsid, destwsid
  931.        external ptk_copylinetable !$PRAGMA C(ptk_copylinetable)
  932.  
  933.        call ptk_copylinetable(%val(sourcewsid), %val(destwsid))
  934.  
  935.        RETURN
  936.        END
  937.  
  938.        SUBROUTINE ptkf_copymarkertable(sourcewsid, destwsid)
  939. C /*
  940. C ** \parambegin
  941. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  942. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  943. C ** \paramend
  944. C ** \blurb{This function copies the polymarker bundle
  945. C **  table from workstation \pardesc{sourcewsid} to
  946. C **  workstation \pardesc{destwsid}.}
  947. C */
  948.        INTEGER sourcewsid, destwsid
  949.        external ptk_copymarkertable !$PRAGMA C(ptk_copymarkertable)
  950.  
  951.        call ptk_copymarkertable(%val(sourcewsid), %val(destwsid))
  952.  
  953.        RETURN
  954.        END
  955.  
  956.        SUBROUTINE ptkf_copytexttable(sourcewsid, destwsid)
  957. C /*
  958. C ** \parambegin
  959. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  960. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  961. C ** \paramend
  962. C ** \blurb{This function copies the text bundle
  963. C **  table from workstation \pardesc{sourcewsid} to
  964. C **  workstation \pardesc{destwsid}.}
  965. C */
  966.        INTEGER sourcewsid, destwsid
  967.        external ptk_copytexttable !$PRAGMA C(ptk_copytexttable)
  968.  
  969.        call ptk_copytexttable(%val(sourcewsid), %val(destwsid))
  970.  
  971.        RETURN
  972.        END
  973.  
  974.        SUBROUTINE ptkf_copyinttable(sourcewsid, destwsid)
  975. C /*
  976. C ** \parambegin
  977. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  978. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  979. C ** \paramend
  980. C ** \blurb{This function copies the interior bundle
  981. C **  table from workstation \pardesc{sourcewsid} to
  982. C **  workstation \pardesc{destwsid}.}
  983. C */
  984.        INTEGER sourcewsid, destwsid
  985.        external ptk_copyinttable !$PRAGMA C(ptk_copyinttable)
  986.  
  987.        call ptk_copyinttable(%val(sourcewsid), %val(destwsid))
  988.  
  989.        RETURN
  990.        END
  991.  
  992.        SUBROUTINE ptkf_copyedgetable(sourcewsid, destwsid)
  993. C /*
  994. C ** \parambegin
  995. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  996. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  997. C ** \paramend
  998. C ** \blurb{This function copies the edge bundle
  999. C **  table from workstation \pardesc{sourcewsid} to
  1000. C **  workstation \pardesc{destwsid}.}
  1001. C */
  1002.        INTEGER sourcewsid, destwsid
  1003.        external ptk_copyedgetable !$PRAGMA C(ptk_copyedgetable)
  1004.  
  1005.        call ptk_copyedgetable(%val(sourcewsid), %val(destwsid))
  1006.  
  1007.        RETURN
  1008.        END
  1009.  
  1010.        SUBROUTINE ptkf_copypattable(sourcewsid, destwsid)
  1011. C /*
  1012. C ** \parambegin
  1013. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  1014. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  1015. C ** \paramend
  1016. C ** \blurb{This function copies the view
  1017. C **  table from workstation \pardesc{sourcewsid} to
  1018. C **  workstation \pardesc{destwsid}.}
  1019. C */
  1020.        INTEGER sourcewsid, destwsid
  1021.        external ptk_copypattable !$PRAGMA C(ptk_copypattable)
  1022.  
  1023.        call ptk_copypattable(%val(sourcewsid), %val(destwsid))
  1024.  
  1025.        RETURN
  1026.        END
  1027.  
  1028.        SUBROUTINE ptkf_copyviewtable(sourcewsid, destwsid)
  1029. C /*
  1030. C ** \parambegin
  1031. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  1032. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  1033. C ** \paramend
  1034. C ** \blurb{This function copies the pattern bundle
  1035. C **  table from workstation \pardesc{sourcewsid} to
  1036. C **  workstation \pardesc{destwsid}.}
  1037. C */
  1038.        INTEGER sourcewsid, destwsid
  1039.        external ptk_copyviewtable !$PRAGMA C(ptk_copyviewtable)
  1040.  
  1041.        call ptk_copyviewtable(%val(sourcewsid), %val(destwsid))
  1042.  
  1043.        RETURN
  1044.        END
  1045.  
  1046.        SUBROUTINE ptkf_copywssttable(sourcewsid, destwsid)
  1047. C /*
  1048. C ** \parambegin
  1049. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  1050. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  1051. C ** \paramend
  1052. C ** \blurb{This function copies the workstation colour,
  1053. C ** polyline bundle, polymarker bundle, interior bundle, edge bundle,
  1054. C ** text bundle, pattern bundle and view
  1055. C **  tables from workstation \pardesc{sourcewsid} to
  1056. C **  workstation \pardesc{destwsid}.}
  1057. C */
  1058.        INTEGER sourcewsid, destwsid
  1059.        external ptk_copywssttable !$PRAGMA C(ptk_copywssttable)
  1060.  
  1061.        call ptk_copywssttable(%val(sourcewsid), %val(destwsid))
  1062.  
  1063.        RETURN
  1064.        END
  1065.  
  1066.        SUBROUTINE ptkf_copypostedstruct(sourcewsid, destwsid)
  1067. C /*
  1068. C ** \parambegin
  1069. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  1070. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  1071. C ** \paramend
  1072. C ** \blurb{This function posts all the structures already posted to
  1073. C ** workstation \pardesc{sourcewsid} to  workstation  \pardesc{destwsid}.}
  1074. C */
  1075.        INTEGER sourcewsid, destwsid
  1076.        external ptk_copypostedstruct !$PRAGMA C(ptk_copypostedstruct)
  1077.  
  1078.        call ptk_copypostedstruct(%val(sourcewsid), %val(destwsid))
  1079.  
  1080.        RETURN
  1081.        END
  1082.  
  1083.        SUBROUTINE ptkf_copyhilightfilter(sourcewsid, destwsid)
  1084. C /*
  1085. C ** \parambegin
  1086. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  1087. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  1088. C ** \paramend
  1089. C ** \blurb{This function copies the highlighting filter 
  1090. C ** from workstation \pardesc{sourcewsid} to workstation \pardesc{destwsid}.}
  1091. C */
  1092.        INTEGER sourcewsid, destwsid
  1093.        external ptk_copyhilightfilter !$PRAGMA C(ptk_copyhilightfilter)
  1094.  
  1095.        call ptk_copyhilightfilter(%val(sourcewsid), %val(destwsid))
  1096.  
  1097.        RETURN
  1098.        END
  1099.  
  1100.        SUBROUTINE ptkf_copyinvisfilter(sourcewsid, destwsid)
  1101. C /*
  1102. C ** \parambegin
  1103. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  1104. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  1105. C ** \paramend
  1106. C ** \blurb{This function copies the invisibilty filter 
  1107. C ** from workstation \pardesc{sourcewsid} to workstation \pardesc{destwsid}.}
  1108. C */
  1109.        INTEGER sourcewsid, destwsid
  1110.        external ptk_copyinvisfilter !$PRAGMA C(ptk_copyinvisfilter)
  1111.  
  1112.        call ptk_copyinvisfilter(%val(sourcewsid), %val(destwsid))
  1113.  
  1114.        RETURN
  1115.        END
  1116.  
  1117.        SUBROUTINE ptkf_copyhlhsrmode(sourcewsid, destwsid)
  1118. C /*
  1119. C ** \parambegin
  1120. C ** \param{INTEGER}{sourcewsid}{source workstation identifier}{IN}
  1121. C ** \param{INTEGER}{destwsid}{destination workstation identifier}{IN}
  1122. C ** \paramend
  1123. C ** \blurb{This function copies the HLHSR mode
  1124. C ** from workstation \pardesc{sourcewsid} to workstation \pardesc{destwsid}.}
  1125. C */
  1126.        INTEGER sourcewsid, destwsid
  1127.        external ptk_copyhlhsrmode !$PRAGMA C(ptk_copyhlhsrmode)
  1128.  
  1129.        call ptk_copyhlhsrmode(%val(sourcewsid), %val(destwsid))
  1130.  
  1131.        RETURN
  1132.        END
  1133.  
  1134.        SUBROUTINE ptkf_inqmaxdevicecoords(wsid, maxdevx, maxdevy)
  1135. C /*
  1136. C ** \parambegin
  1137. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  1138. C ** \param{REAL}{maxdevx}{maximum device coords along x axis}{OUT}
  1139. C ** \param{REAL}{maxdevy}{maximum device coords along y axis}{OUT}
  1140. C ** \paramend
  1141. C ** \blurb{This function returns the the 
  1142. C ** maximum device coordinates for $x$ and $y$ for workstation 
  1143. C ** \pardesc{wsid}.}
  1144. C */
  1145.        INTEGER wsid
  1146.        REAL maxdevx, maxdevy
  1147.        external ptk_inqmaxdevicecoords 
  1148. & !$PRAGMA C(ptk_inqmaxdevicecoords)
  1149.  
  1150.        call ptk_inqmaxdevicecoords(%val(wsid), maxdevx, maxdevy)
  1151.  
  1152.        RETURN
  1153.        END
  1154.  
  1155.        SUBROUTINE ptkf_inqmaxdevicecoords3(wsid, maxdevx, maxdevy)
  1156. C /*
  1157. C ** \parambegin
  1158. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  1159. C ** \param{REAL}{maxdevx}{maximum device coords along x axis}{OUT}
  1160. C ** \param{REAL}{maxdevy}{maximum device coords along y axis}{OUT}
  1161. C ** \param{REAL}{maxdevz}{maximum device coords along z axis}{OUT}
  1162. C ** \paramend
  1163. C ** \blurb{This function returns the the 
  1164. C ** maximum device coordinates for $x$, $y$
  1165. C ** and $z$ for workstation \pardesc{wsid}.}
  1166. C */
  1167.        INTEGER wsid
  1168.        REAL maxdevx, maxdevy, maxdevz
  1169.        external ptk_inqmaxdevicecoords3 
  1170. & !$PRAGMA C(ptk_inqmaxdevicecoords3)
  1171.  
  1172.        call ptk_inqmaxdevicecoords3(%val(wsid), maxdevx, maxdevy, 
  1173. & maxdevz)
  1174.  
  1175.        RETURN
  1176.        END
  1177.  
  1178.        SUBROUTINE ptkf_arrow(length, width, centre, angle)
  1179. C /*
  1180. C ** \parambegin
  1181. C ** \param{REAL}{length}{length of arrow}{IN}
  1182. C ** \param{REAL}{width}{width of arrow}{IN}
  1183. C ** \param{REAL}{centre(3)}{centre of arrow}{IN}
  1184. C ** \param{REAL}{angle}{rotation of arrow in degrees anti-clockwise about 
  1185. C ** arrow pointing along x-axis.}{IN}
  1186. C ** \paramend
  1187. C ** \blurb{This function draws an arrow with the specified
  1188. C ** length \pardesc{length} and \pardesc{width}, rotated through
  1189. C **  \pardesc{angle}, centred at \pardesc{centre}.} 
  1190. C */
  1191.        REAL length, width, centre(3), angle
  1192.        REAL*8 dplength, dpwidth, dpangle
  1193.        external ptk_arrow !$PRAGMA C(ptk_arrow)
  1194.  
  1195.        dplength = length
  1196.        dpwidth = width
  1197.        dpangle = angle
  1198.        call ptk_arrow(%val(dplength), %val(dpwidth), centre, 
  1199. & %val(dpangle))
  1200.  
  1201.        RETURN
  1202.        END
  1203.  
  1204.        SUBROUTINE ptkf_grid(stid)
  1205. C /*
  1206. C ** \parambegin
  1207. C ** \param{INTEGER}{stid}{grid structure identifier}{IN}
  1208. C ** \paramend
  1209. C ** \blurb{This functions draws a grid of lines on [0,1],
  1210. C **  into structure \pardesc{stid}. }
  1211. C */
  1212.        INTEGER stid
  1213.        external ptk_grid !$PRAGMA C(ptk_grid)
  1214.  
  1215.        call ptk_grid(%val(stid))
  1216.  
  1217.        RETURN
  1218.        END
  1219.  
  1220.        SUBROUTINE ptkf_framebox(boxcentre, boxsize, framesize, 
  1221. & boxcolour, edgecolour, tlcolour, brcolour)
  1222. C /*
  1223. C ** \parambegin
  1224. C ** \param{REAL}{boxcentre(3)}{centre of box}{IN}
  1225. C ** \param{REAL}{boxsize(2)}{height and width box}{IN}
  1226. C ** \param{REAL}{framesize(2)}{height and width of frame}{IN}
  1227. C ** \param{INTEGER}{boxcolour}{box interior colour index}{IN}
  1228. C ** \param{INTEGER}{edgecolour}{box edge colour index}{IN}
  1229. C ** \param{INTEGER}{tlcolour}{frame top-left colour index}{IN}
  1230. C ** \param{INTEGER}{brcolour}{frame bottom-right colour index}{IN}
  1231. C ** \paramend
  1232. C ** \blurb{This function draws a box in the open
  1233. C **  structure with a frame to give a 3D
  1234. C ** effect.}
  1235. C */
  1236.        REAL boxcentre(3), boxsize(2), framesize(2)
  1237.        INTEGER boxcolour, edgecolour, tlcolour, brcolour
  1238.        external ptk_framebox !$PRAGMA C(ptk_framebox)
  1239.  
  1240.        call ptk_framebox(boxcentre, boxsize, framesize,
  1241. & %val(boxcolour), %val(edgecolour), %val(tlcolour), %val(brcolour))
  1242.  
  1243.        RETURN
  1244.        END
  1245.  
  1246. C end of plib.f 
  1247.